home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / getopt-long.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  19.6 KB  |  426 lines
  1. ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
  2. ;;;
  3. ;; This library is free software; you can redistribute it and/or
  4. ;; modify it under the terms of the GNU Lesser General Public
  5. ;; License as published by the Free Software Foundation; either
  6. ;; version 2.1 of the License, or (at your option) any later version.
  7. ;; 
  8. ;; This library is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;; 
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this library; if not, write to the Free Software
  15. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16.  
  17. ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
  18.  
  19. ;;; Commentary:
  20.  
  21. ;;; This module implements some complex command line option parsing, in
  22. ;;; the spirit of the GNU C library function `getopt_long'.  Both long
  23. ;;; and short options are supported.
  24. ;;;
  25. ;;; The theory is that people should be able to constrain the set of
  26. ;;; options they want to process using a grammar, rather than some arbitrary
  27. ;;; structure.  The grammar makes the option descriptions easy to read.
  28. ;;;
  29. ;;; `getopt-long' is a procedure for parsing command-line arguments in a
  30. ;;; manner consistent with other GNU programs.  `option-ref' is a procedure
  31. ;;; that facilitates processing of the `getopt-long' return value.
  32.  
  33. ;;; (getopt-long ARGS GRAMMAR)
  34. ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
  35. ;;;
  36. ;;; ARGS should be a list of strings.  Its first element should be the
  37. ;;; name of the program; subsequent elements should be the arguments
  38. ;;; that were passed to the program on the command line.  The
  39. ;;; `program-arguments' procedure returns a list of this form.
  40. ;;;
  41. ;;; GRAMMAR is a list of the form:
  42. ;;; ((OPTION (PROPERTY VALUE) ...) ...)
  43. ;;;
  44. ;;; Each OPTION should be a symbol.  `getopt-long' will accept a
  45. ;;; command-line option named `--OPTION'.
  46. ;;; Each option can have the following (PROPERTY VALUE) pairs:
  47. ;;;
  48. ;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
  49. ;;;        equivalent to `--OPTION'.  This is how to specify traditional
  50. ;;;        Unix-style flags.
  51. ;;;   (required? BOOL) --- If BOOL is true, the option is required.
  52. ;;;        getopt-long will raise an error if it is not found in ARGS.
  53. ;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
  54. ;;;        it is #f, it does not; and if it is the symbol
  55. ;;;        `optional', the option may appear in ARGS with or
  56. ;;;        without a value.
  57. ;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
  58. ;;;        specified `(value #t)' for this option), then getopt
  59. ;;;        will apply FUNC to the value, and throw an exception
  60. ;;;        if it returns #f.  FUNC should be a procedure which
  61. ;;;        accepts a string and returns a boolean value; you may
  62. ;;;        need to use quasiquotes to get it into GRAMMAR.
  63. ;;;
  64. ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
  65. ;;; property may occur only once.  By default, options do not have
  66. ;;; single-character equivalents, are not required, and do not take
  67. ;;; values.
  68. ;;;
  69. ;;; In ARGS, single-character options may be combined, in the usual
  70. ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
  71. ;;; accepts values, then it must be the last option in the
  72. ;;; combination; the value is the next argument.  So, for example, using
  73. ;;; the following grammar:
  74. ;;;      ((apples    (single-char #\a))
  75. ;;;       (blimps    (single-char #\b) (value #t))
  76. ;;;       (catalexis (single-char #\c) (value #t)))
  77. ;;; the following argument lists would be acceptable:
  78. ;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
  79. ;;;                                         for "blimps" and "catalexis")
  80. ;;;    ("-ab" "bang" "-c" "couth")         (same)
  81. ;;;    ("-ac" "couth" "-b" "bang")         (same)
  82. ;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
  83. ;;;                                         last option in its combination)
  84. ;;;
  85. ;;; If an option's value is optional, then `getopt-long' decides
  86. ;;; whether it has a value by looking at what follows it in ARGS.  If
  87. ;;; the next element is does not appear to be an option itself, then
  88. ;;; that element is the option's value.
  89. ;;;
  90. ;;; The value of a long option can appear as the next element in ARGS,
  91. ;;; or it can follow the option name, separated by an `=' character.
  92. ;;; Thus, using the same grammar as above, the following argument lists
  93. ;;; are equivalent:
  94. ;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
  95. ;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
  96. ;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
  97. ;;;
  98. ;;; If the option "--" appears in ARGS, argument parsing stops there;
  99. ;;; subsequent arguments are returned as ordinary arguments, even if
  100. ;;; they resemble options.  So, in the argument list:
  101. ;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
  102. ;;; `getopt-long' will recognize the `apples' option as having the
  103. ;;; value "Granny Smith", but it will not recognize the `blimp'
  104. ;;; option; it will return the strings "--blimp" and "Goodyear" as
  105. ;;; ordinary argument strings.
  106. ;;;
  107. ;;; The `getopt-long' function returns the parsed argument list as an
  108. ;;; assocation list, mapping option names --- the symbols from GRAMMAR
  109. ;;; --- onto their values, or #t if the option does not accept a value.
  110. ;;; Unused options do not appear in the alist.
  111. ;;;
  112. ;;; All arguments that are not the value of any option are returned
  113. ;;; as a list, associated with the empty list.
  114. ;;;
  115. ;;; `getopt-long' throws an exception if:
  116. ;;; - it finds an unrecognized property in GRAMMAR
  117. ;;; - the value of the `single-char' property is not a character
  118. ;;; - it finds an unrecognized option in ARGS
  119. ;;; - a required option is omitted
  120. ;;; - an option that requires an argument doesn't get one
  121. ;;; - an option that doesn't accept an argument does get one (this can
  122. ;;;   only happen using the long option `--opt=value' syntax)
  123. ;;; - an option predicate fails
  124. ;;;
  125. ;;; So, for example:
  126. ;;;
  127. ;;; (define grammar
  128. ;;;   `((lockfile-dir (required? #t)
  129. ;;;                   (value #t)
  130. ;;;                   (single-char #\k)
  131. ;;;                   (predicate ,file-is-directory?))
  132. ;;;     (verbose (required? #f)
  133. ;;;              (single-char #\v)
  134. ;;;              (value #f))
  135. ;;;     (x-includes (single-char #\x))
  136. ;;;     (rnet-server (single-char #\y)
  137. ;;;                  (predicate ,string?))))
  138. ;;;
  139. ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
  140. ;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
  141. ;;;                grammar)
  142. ;;; => ((() "foo1" "-fred" "foo2" "foo3")
  143. ;;;     (rnet-server . "lamprod")
  144. ;;;     (x-includes . "/usr/include")
  145. ;;;     (lockfile-dir . "/tmp")
  146. ;;;     (verbose . #t))
  147.  
  148. ;;; (option-ref OPTIONS KEY DEFAULT)
  149. ;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
  150. ;;; found.  The value is either a string or `#t'.
  151. ;;;
  152. ;;; For example, using the `getopt-long' return value from above:
  153. ;;;
  154. ;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
  155. ;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
  156.  
  157. ;;; Code:
  158.  
  159. (define-module (ice-9 getopt-long)
  160.   :use-module ((ice-9 common-list) :select (some remove-if-not))
  161.   :export (getopt-long option-ref))
  162.  
  163. (define option-spec-fields '(name
  164.                              value
  165.                              required?
  166.                              single-char
  167.                              predicate
  168.                              value-policy))
  169.  
  170. (define option-spec (make-record-type 'option-spec option-spec-fields))
  171. (define make-option-spec (record-constructor option-spec option-spec-fields))
  172.  
  173. (define (define-one-option-spec-field-accessor field)
  174.   `(define ,(symbol-append 'option-spec-> field)        ;;; name slib-compat
  175.      (record-accessor option-spec ',field)))
  176.  
  177. (define (define-one-option-spec-field-modifier field)
  178.   `(define ,(symbol-append 'set-option-spec- field '!)  ;;; name slib-compat
  179.      (record-modifier option-spec ',field)))
  180.  
  181. (defmacro define-all-option-spec-accessors/modifiers ()
  182.   `(begin
  183.      ,@(map define-one-option-spec-field-accessor option-spec-fields)
  184.      ,@(map define-one-option-spec-field-modifier option-spec-fields)))
  185.  
  186. (define-all-option-spec-accessors/modifiers)
  187.  
  188. (define make-option-spec
  189.   (let ((ctor (record-constructor option-spec '(name))))
  190.     (lambda (name)
  191.       (ctor name))))
  192.  
  193. (define (parse-option-spec desc)
  194.   (let ((spec (make-option-spec (symbol->string (car desc)))))
  195.     (for-each (lambda (desc-elem)
  196.                 (let ((given (lambda () (cadr desc-elem))))
  197.                   (case (car desc-elem)
  198.                     ((required?)
  199.                      (set-option-spec-required?! spec (given)))
  200.                     ((value)
  201.                      (set-option-spec-value-policy! spec (given)))
  202.                     ((single-char)
  203.                      (or (char? (given))
  204.                          (error "`single-char' value must be a char!"))
  205.                      (set-option-spec-single-char! spec (given)))
  206.                     ((predicate)
  207.                      (set-option-spec-predicate!
  208.                       spec ((lambda (pred)
  209.                               (lambda (name val)
  210.                                 (or (not val)
  211.                                     (pred val)
  212.                                     (error "option predicate failed:" name))))
  213.                             (given))))
  214.                     (else
  215.                      (error "invalid getopt-long option property:"
  216.                             (car desc-elem))))))
  217.               (cdr desc))
  218.     spec))
  219.  
  220. (define (split-arg-list argument-list)
  221.   ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
  222.   ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
  223.   (let loop ((yes '()) (no argument-list))
  224.     (cond ((null? no)               (cons (reverse yes) no))
  225.       ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
  226.       (else (loop (cons (car no) yes) (cdr no))))))
  227.  
  228. (define short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
  229. (define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
  230. (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
  231.  
  232. (define (match-substring match which)
  233.   ;; condensed from (ice-9 regex) `match:{substring,start,end}'
  234.   (let ((sel (vector-ref match (1+ which))))
  235.     (substring (vector-ref match 0) (car sel) (cdr sel))))
  236.  
  237. (define (expand-clumped-singles opt-ls)
  238.   ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
  239.   (let loop ((opt-ls opt-ls) (ret-ls '()))
  240.     (cond ((null? opt-ls)
  241.            (reverse ret-ls))                                    ;;; retval
  242.           ((regexp-exec short-opt-rx (car opt-ls))
  243.            => (lambda (match)
  244.                 (let ((singles (reverse
  245.                                 (map (lambda (c)
  246.                                        (string-append "-" (make-string 1 c)))
  247.                                      (string->list
  248.                                       (match-substring match 1)))))
  249.                       (extra (match-substring match 2)))
  250.                   (loop (cdr opt-ls)
  251.                         (append (if (string=? "" extra)
  252.                                     singles
  253.                                     (cons extra singles))
  254.                                 ret-ls)))))
  255.           (else (loop (cdr opt-ls)
  256.                       (cons (car opt-ls) ret-ls))))))
  257.  
  258. (define (looks-like-an-option string)
  259.   (some (lambda (rx)
  260.           (regexp-exec rx string))
  261.         `(,short-opt-rx
  262.           ,long-opt-with-value-rx
  263.           ,long-opt-no-value-rx)))
  264.  
  265. (define (process-options specs argument-ls)
  266.   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
  267.   ;; FOUND is an unordered list of option specs for found options, while ETC
  268.   ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
  269.   ;; options nor their values.
  270.   (let ((idx (map (lambda (spec)
  271.                     (cons (option-spec->name spec) spec))
  272.                   specs))
  273.         (sc-idx (map (lambda (spec)
  274.                        (cons (make-string 1 (option-spec->single-char spec))
  275.                              spec))
  276.                      (remove-if-not option-spec->single-char specs))))
  277.     (let loop ((argument-ls argument-ls) (found '()) (etc '()))
  278.       (let ((eat! (lambda (spec ls)
  279.                     (let ((val!loop (lambda (val n-ls n-found n-etc)
  280.                                       (set-option-spec-value!
  281.                                        spec
  282.                                        ;; handle multiple occurrances
  283.                                        (cond ((option-spec->value spec)
  284.                                               => (lambda (cur)
  285.                                                    ((if (list? cur) cons list)
  286.                                                     val cur)))
  287.                                              (else val)))
  288.                                       (loop n-ls n-found n-etc)))
  289.                           (ERR:no-arg (lambda ()
  290.                                         (error (string-append
  291.                                                 "option must be specified"
  292.                                                 " with argument:")
  293.                                                (option-spec->name spec)))))
  294.                       (cond
  295.                        ((eq? 'optional (option-spec->value-policy spec))
  296.                         (if (or (null? (cdr ls))
  297.                                 (looks-like-an-option (cadr ls)))
  298.                             (val!loop #t
  299.                                       (cdr ls)
  300.                                       (cons spec found)
  301.                                       etc)
  302.                             (val!loop (cadr ls)
  303.                                       (cddr ls)
  304.                                       (cons spec found)
  305.                                       etc)))
  306.                        ((eq? #t (option-spec->value-policy spec))
  307.                         (if (or (null? (cdr ls))
  308.                                 (looks-like-an-option (cadr ls)))
  309.                             (ERR:no-arg)
  310.                             (val!loop (cadr ls)
  311.                                       (cddr ls)
  312.                                       (cons spec found)
  313.                                       etc)))
  314.                        (else
  315.                         (val!loop #t
  316.                                   (cdr ls)
  317.                                   (cons spec found)
  318.                                   etc)))))))
  319.         (if (null? argument-ls)
  320.             (cons found (reverse etc))                          ;;; retval
  321.             (cond ((regexp-exec short-opt-rx (car argument-ls))
  322.                    => (lambda (match)
  323.                         (let* ((c (match-substring match 1))
  324.                                (spec (or (assoc-ref sc-idx c)
  325.                                          (error "no such option:" c))))
  326.                           (eat! spec argument-ls))))
  327.                   ((regexp-exec long-opt-no-value-rx (car argument-ls))
  328.                    => (lambda (match)
  329.                         (let* ((opt (match-substring match 1))
  330.                                (spec (or (assoc-ref idx opt)
  331.                                          (error "no such option:" opt))))
  332.                           (eat! spec argument-ls))))
  333.                   ((regexp-exec long-opt-with-value-rx (car argument-ls))
  334.                    => (lambda (match)
  335.                         (let* ((opt (match-substring match 1))
  336.                                (spec (or (assoc-ref idx opt)
  337.                                          (error "no such option:" opt))))
  338.                           (if (option-spec->value-policy spec)
  339.                               (eat! spec (append
  340.                                           (list 'ignored
  341.                                                 (match-substring match 2))
  342.                                           (cdr argument-ls)))
  343.                               (error "option does not support argument:"
  344.                                      opt)))))
  345.                   (else
  346.                    (loop (cdr argument-ls)
  347.                          found
  348.                          (cons (car argument-ls) etc)))))))))
  349.  
  350. (define (getopt-long program-arguments option-desc-list)
  351.   "Process options, handling both long and short options, similar to
  352. the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
  353. similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
  354. list of option descriptions.  Each option description must satisfy the
  355. following grammar:
  356.  
  357.     <option-spec>           :: (<name> . <attribute-ls>)
  358.     <attribute-ls>          :: (<attribute> . <attribute-ls>)
  359.                                | ()
  360.     <attribute>             :: <required-attribute>
  361.                                | <arg-required-attribute>
  362.                                | <single-char-attribute>
  363.                                | <predicate-attribute>
  364.                                | <value-attribute>
  365.     <required-attribute>    :: (required? <boolean>)
  366.     <single-char-attribute> :: (single-char <char>)
  367.     <value-attribute>       :: (value #t)
  368.                                (value #f)
  369.                                (value optional)
  370.     <predicate-attribute>   :: (predicate <1-ary-function>)
  371.  
  372.     The procedure returns an alist of option names and values.  Each
  373. option name is a symbol.  The option value will be '#t' if no value
  374. was specified.  There is a special item in the returned alist with a
  375. key of the empty list, (): the list of arguments that are not options
  376. or option values.
  377.     By default, options are not required, and option values are not
  378. required.  By default, single character equivalents are not supported;
  379. if you want to allow the user to use single character options, you need
  380. to add a `single-char' clause to the option description."
  381.   (let* ((specifications (map parse-option-spec option-desc-list))
  382.      (pair (split-arg-list (cdr program-arguments)))
  383.      (split-ls (expand-clumped-singles (car pair)))
  384.      (non-split-ls (cdr pair))
  385.          (found/etc (process-options specifications split-ls))
  386.          (found (car found/etc))
  387.          (rest-ls (append (cdr found/etc) non-split-ls)))
  388.     (for-each (lambda (spec)
  389.                 (let ((name (option-spec->name spec))
  390.                       (val (option-spec->value spec)))
  391.                   (and (option-spec->required? spec)
  392.                        (or (memq spec found)
  393.                            (error "option must be specified:" name)))
  394.                   (and (memq spec found)
  395.                        (eq? #t (option-spec->value-policy spec))
  396.                        (or val
  397.                            (error "option must be specified with argument:"
  398.                                   name)))
  399.                   (let ((pred (option-spec->predicate spec)))
  400.                     (and pred (pred name val)))))
  401.               specifications)
  402.     (cons (cons '() rest-ls)
  403.           (let ((multi-count (map (lambda (desc)
  404.                                     (cons (car desc) 0))
  405.                                   option-desc-list)))
  406.             (map (lambda (spec)
  407.                    (let ((name (string->symbol (option-spec->name spec))))
  408.                      (cons name
  409.                            ;; handle multiple occurrances
  410.                            (let ((maybe-ls (option-spec->value spec)))
  411.                              (if (list? maybe-ls)
  412.                                  (let* ((look (assq name multi-count))
  413.                                         (idx (cdr look))
  414.                                         (val (list-ref maybe-ls idx)))
  415.                                    (set-cdr! look (1+ idx)) ; ugh!
  416.                                    val)
  417.                                  maybe-ls)))))
  418.                  found)))))
  419.  
  420. (define (option-ref options key default)
  421.   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
  422. The value is either a string or `#t'."
  423.   (or (assq-ref options key) default))
  424.  
  425. ;;; getopt-long.scm ends here
  426.